home *** CD-ROM | disk | FTP | other *** search
/ Die Ultimative Software-P…i Collection 1996 & 1997 / Die Ultimative Software-Pakete CD-ROM fur Atari Collection 1996 & 1997.iso / a / a_funk / hammap1.tos / DIGI_MAP / CHKMAP.PAS next >
Encoding:
Pascal/Delphi Source File  |  1992-08-05  |  13.5 KB  |  545 lines
  1. PROGRAM CheckMap;
  2.  
  3. CONST CallLength  = 9;
  4.       DefFileName = 'DIGIMAP';
  5.       DefDatExt   = '.DAT';
  6.       DefErrExt   = '.ERR';
  7.  
  8. TYPE errTyp  = (E_NOCOMMA, E_NOCALL , E_LOCLEN , E_TYPVAL ,
  9.                 E_TYPERR , E_FREQVAL, E_RADVAL , E_NOLBRA ,
  10.                 E_NORBRA , E_NOLCALL, E_COMLEN , E_NOLINK ,
  11.                 E_LINKTYP, E_NOENTRY, E_DOUBLE, E_NOSORT);
  12.  
  13.      recPtr  = ^recTyp;
  14.      linkPtr = ^linkTyp;
  15.      str255  = string[255];
  16.  
  17.      linkTyp = RECORD
  18.                  recP: recPtr;
  19.                  lTyp: Char;
  20.                  next: linkPtr
  21.                END;
  22.      Longint = Long_Integer;
  23.      Word    = Integer;
  24.  
  25.      recTyp  = RECORD
  26.                  lNum   : Integer;
  27.                  call   : String[CallLength];
  28.                  loc    : String[6];
  29.                  freq   : Longint;
  30.                  typ    : Byte;
  31.                  rad    : Word;
  32.                  links  : linkPtr;
  33.                  comment: String[70];
  34.                  next   : recPtr
  35.                END;
  36.  
  37. VAR LineNum    : Integer;
  38.     recNum     : Integer;
  39.     errcnt     : Integer;
  40.     hierHeap   : ^Integer;
  41.     LastCall   : String[CallLength];
  42.     DatFileName: String[12];
  43.     ErrFileName: String[12];
  44.     Line       : str255;
  45.     dat        : Text;
  46.     err        : Text;
  47.     rem        : Boolean;
  48.     datOpen    : Boolean;
  49.     recRoot    : recPtr;
  50.     nulrec     : recTyp;
  51.     nullink    : linkTyp;
  52.     ParamCount : integer;
  53.     ParamStr   : str255;
  54.  
  55. procedure gotoxy(x,y: integer);                { Cursor positionieren }
  56. begin
  57.   write(chr(27),'Y',chr(y+32),chr(x+32));
  58. end;
  59.  
  60. procedure clreol;                           { bis zum Zeilenende löschen }
  61. begin
  62.   write(chr(27),'K');
  63. end;
  64.  
  65. procedure inc(var l: integer);
  66. begin
  67.     l := l + 1;
  68. end;
  69.  
  70. procedure dec(var l: integer);
  71. begin
  72.     l := l - 1;
  73. end;
  74.  
  75. function UpCase(c: char):char;
  76. begin
  77.     if (ord(c) > 96) and (ord(c) < 126) then
  78.         UpCase := chr(ord(c)-32) else UpCase := c;
  79. end;
  80.  
  81. PROCEDURE StopIt;                {Bei Chaos: geordnet raus hier}
  82. BEGIN
  83.   IF datOpen THEN Close(dat);
  84.   IF hierHeap<>NIL THEN Release(hierHeap);
  85.   Halt;
  86. END;
  87.  
  88. PROCEDURE Fehler(code: errTyp; s1,s2: String);    {Fehlernummer in Klartext}
  89. BEGIN
  90.   Inc(errcnt);
  91.   Write(err,LineNum:4,': ');
  92.   CASE code OF
  93.     E_NOCOMMA: Write(err,''','' missing');
  94.     E_NOCALL : Write(err,'Invalid callsign ',s1);
  95.     E_LOCLEN : Write(err,'wrong Locator length');
  96.     E_TYPVAL : Write(err,'Type value error');
  97.     E_TYPERR : Write(err,'Wrong TYPE value ',s1);
  98.     E_FREQVAL: Write(err,'Wrong freq value ',s1);
  99.     E_LINKTYP: Write(err,s1,': wrong linktyp to ',s2);
  100.     E_NOENTRY: Write(err,s1,': no entry');
  101.     E_DOUBLE : Write(err,s1,': double entry');
  102.     E_NOLINK : Write(err,s1,': no link to ',s2);
  103.     E_RADVAL : Write(err,'Wrong RAD entry');
  104.     E_NOLBRA : Write(err,'Missing left brace');
  105.     E_NORBRA : Write(err,'Missing right brace');
  106.     E_NOLCALL: Write(err,'Invalid link callsign',s1);
  107.     E_COMLEN : Write(err,'Too much comment');
  108.     E_NOSORT : Write(err,'Not in alphabetical order');
  109.     ELSE       Write(err,'Unknown error');
  110.   END;
  111.   WriteLn(err);
  112. END;
  113.  
  114. PROCEDURE trim(VAR s: String);            { Leerzeichen entfernen }
  115. VAR l: Integer;
  116. BEGIN
  117.   WHILE(s>'') AND (s[1]=' ') DO
  118.     Delete(s,1,1);
  119.   l := Length(s);
  120.   WHILE(l>0) AND (s[l]=' ') DO 
  121.   BEGIN
  122.     Delete(s,l,1);
  123.     dec(l);
  124.   END;
  125. END;
  126.  
  127. PROCEDURE toUpper(VAR s: String);     { in Großbuchstaben umwandeln }
  128. VAR i: Integer;
  129. BEGIN
  130.   FOR i:=1 TO Length(s) DO
  131.     s[i]:=UpCase(s[i]);
  132. END;
  133.  
  134. PROCEDURE Help;                            { wat wohl? }
  135. BEGIN
  136.   writeln('TNX to LX9EG, DC7OS, DH4DAI etc.');
  137.   writeln('See CHKMAP.DOC for more information!');
  138.   writeln;
  139.   writeln('Usage: CHKMAP [/?][filename.ext]',chr(10));
  140.  
  141.   writeln('Example: CHKMAP               checks DIGIMAP.DAT in the current directory');
  142.   writeln('         CHKMAP filename.ext  checks <filename.ext>');
  143.   writeln('         CHKMAP /?            this help screen',chr(10));
  144.   halt;
  145. END;
  146.  
  147. PROCEDURE getFileName;                   { Filenamen zusammenbasteln }
  148. VAR fnm: String;
  149.     ext: String;
  150.     p  : Integer;
  151. BEGIN
  152.   IF ParamCount=0 THEN                   { Wenn keine Parameter, dann Default } 
  153.   BEGIN
  154.     fnm:=DefFileName;
  155.     ext:=DefDatExt;
  156.   END
  157.   ELSE 
  158.   BEGIN                                  { sonst: mal sehen, was kommt! }
  159.     Line:=ParamStr;
  160.     IF Line='/?' THEN Help;              { Hilfe gefällig? }
  161.     p:=Pos('.',Line);
  162.     IF p=0 THEN 
  163.     BEGIN
  164.       fnm:=Copy(Line,1,8);
  165.       ext:='';
  166.     END
  167.     ELSE 
  168.     BEGIN
  169.       ext:=Copy(Line,p,4);
  170.       IF p>9 THEN p:=9;
  171.       fnm:=Copy(Line,1,Pred(p));
  172.     END;
  173.     toUpper(fnm);
  174.     toUpper(Ext);
  175.   END;
  176.   DatFileName:=concat(fnm,ext);
  177.   ErrFileName:=concat(fnm,DefErrExt);
  178. END;
  179.  
  180. PROCEDURE CheckLinks;                        { Links checken, ob in Ordnung         }
  181. VAR rec  : recPtr;                          { wen die Funktionsweise interessiert, }
  182.     link : linkPtr;                         { der soll's sich mal aufmalen.        }
  183.     link1: linkPtr;
  184.     exit1: boolean;
  185.     dummy: integer;
  186. BEGIN
  187.   rec:=recRoot^.next;
  188.   WHILE rec<>NIL DO                            { sämtliche Links } 
  189.   BEGIN
  190.     LineNum := rec^.lNum;
  191.     gotoxy(0,9); clreol; write(rec^.lNum,':',rec^.call);
  192.     if rec^.lNum = 0 then Fehler(E_NOENTRY,rec^.call,'')
  193.     else
  194.     begin
  195.       link := rec^.links;
  196.       while link <> NIL do
  197.       begin
  198.         gotoxy(21,9); clreol; write(link^.recP^.call);
  199.         if link^.recP^.lNum <> 0 then
  200.         begin
  201.            link1 := link^.recP^.links;
  202.            exit1 := (link1 = NIL);
  203.            while (link1 <> NIL) and (not exit1) do
  204.            begin
  205.              gotoxy(32,9); clreol; write(link1^.recP^.call);
  206.              if (link1^.recP <> rec) then link1 := link1^.next
  207.                                      else exit1 := TRUE;
  208.            end;
  209.              if (link1 <> NIL) then
  210.              begin
  211.              if (link1^.recP <> rec) then
  212.                Fehler(E_NOLINK,rec^.call,link^.recP^.call)
  213.                 else
  214.                if link1^.lTyp <> link^.lTyp then
  215.                  Fehler(E_LINKTYP,rec^.call,link^.recP^.call);
  216.            end
  217.            else Fehler(E_NOLINK,rec^.call,link^.recP^.call);
  218.         end
  219.         else Fehler(E_NOLINK,rec^.call,link^.recP^.call);
  220.         link := link^.next;
  221.       end;
  222.     end;
  223.     rec := rec^.next;
  224.   end;
  225. end;
  226.  
  227. FUNCTION invalidCall(s: String ): Boolean;    { Rufzeichen checken }
  228. VAR i,l   : Integer;
  229.     isCall: Boolean;
  230. BEGIN
  231.   isCall:=True;
  232.   i:=1;
  233.   l:=Length(s);
  234.   WHILE(i<=l) AND isCall DO 
  235.   BEGIN                                     { nur provisorisch; ausbaufähig! }
  236.     isCall:=s[i] IN ['0'..'9','A'..'Z','-'];
  237.     Inc(i);
  238.   END;
  239.   invalidCall:=NOT isCall
  240. END;
  241.  
  242. FUNCTION findCall(call: String ): recPtr;        { Call suchen }
  243. VAR rPre, rAct: recPtr;
  244.     found     : boolean;
  245. BEGIN
  246. {  call:=Copy(call,1,CallLength);}
  247.   rPre:=recRoot;
  248.   rAct:=rPre^.next;
  249.   found := false;
  250.   WHILE ((rAct<>NIL) and (not found)) DO
  251.     if (rAct^.call <=  call) then
  252.     BEGIN
  253.       rPre:=rAct;
  254.       rAct:=rPre^.next
  255.     END
  256.     else found := true; 
  257.   IF call=rPre^.call THEN findCall:=rPre
  258.   ELSE 
  259.   BEGIN
  260.     New(rAct);
  261.     rAct^:=nulrec;
  262.     rAct^.call:=call;
  263.     rAct^.next:=rPre^.next;
  264.     rPre^.next:=rAct;
  265.     findCall:=rAct;
  266.   END;
  267. END;
  268.  
  269. PROCEDURE Decode(Line: str255);                { Daten aufdröseln }
  270. label 1;
  271. VAR Line1      : str255;
  272.     Line2      : str255;
  273.     rec        : recPtr;
  274.     link       : linkPtr;
  275.     link1      : linkPtr;
  276.     p          : Integer;
  277.     valCode    : Integer;
  278.     value      : Real;
  279.    SpecialLinks: SET OF Char;
  280.  
  281.  PROCEDURE MoveLine;                        { Zeile aufteilen }
  282.  BEGIN
  283.    Line1:=Copy(Line,1,Pred(p));
  284.    trim(Line1);
  285.    Delete(Line,1,p);
  286.  END;
  287.  
  288.  function min(x,y: integer):integer;
  289.  begin
  290.    if x<y then min := x else min := y;
  291.  end;
  292.  
  293.  procedure Val(s: string; var wert: real; err: integer); { String in real }
  294.  var i: integer;
  295.  begin
  296.    err := 0;
  297.    for i := 1 to length(s) do if not (s[i] in ['0'..'9','.']) then err := 1;
  298.    if err = 0 then readv(s,wert);
  299.  end;
  300.  
  301. BEGIN
  302.   SpecialLinks := ['$','@','#','?','!','&','%'];
  303.   p:=Pos(',',Line);                               { Rufzeichen überprüfen }
  304.   IF p>10 THEN
  305.   BEGIN
  306.     Fehler(E_NOCOMMA,'','');
  307.     goto 1;
  308.   END;
  309.   MoveLine;
  310.   toUpper(Line1);
  311.   IF invalidCall(Line1)= true THEN 
  312.   BEGIN
  313.     Fehler(E_NOCALL,Line1,'');
  314.     goto 1;
  315.   END;
  316.   rec:=findCall(Line1);
  317.   IF rec^.call=LastCall THEN Fehler(E_DOUBLE,Line1,'');
  318.   if rec^.call<LastCall THEN Fehler(E_NOSORT,'','');
  319.   LastCall:=rec^.call;
  320.   rec^.lNum:=LineNum;
  321.   p:=Pos(',',Line);                                  { Locator prüfen }
  322.   IF p>7 THEN 
  323.   BEGIN
  324.     Fehler(E_NOCOMMA,'','');
  325.     goto 1;
  326.   END;
  327.   MoveLine;
  328.   p:=Length(Line1);
  329.   IF ((p<>6) and (p <>0)) THEN 
  330.   BEGIN
  331.     Fehler(E_LOCLEN,'','');
  332.     goto 1;
  333.   END;
  334.   rec^.loc:=Line1;
  335.   p:=Pos(',',Line);                                { Typ prüfen }
  336.   IF p <> 2 THEN 
  337.   BEGIN
  338.     Fehler(E_NOCOMMA,'','');
  339.     goto 1;
  340.   END;
  341.   MoveLine;
  342.   Val(Line1,value,valCode);
  343.   IF valCode<>0 THEN 
  344.   BEGIN
  345.     Fehler(E_TYPVAL,'','');
  346.     goto 1;
  347.   END;
  348.   IF(value<1) OR (value>5) THEN 
  349.   BEGIN
  350.     Fehler(E_TYPERR,Line1,'');
  351.     goto 1;
  352.   END;
  353.   rec^.typ:=trunc(value);
  354.   p:=Pos(',',Line);                           { Frequenz prüfen }
  355.   IF p>9 THEN 
  356.   BEGIN
  357.     Fehler(E_NOCOMMA,'','');
  358.     goto 1;
  359.   END;
  360.   MoveLine;
  361.   IF Line1='' THEN rec^.freq:=0
  362.   ELSE 
  363.   BEGIN
  364.     Val(Line1,value,valCode);
  365.     IF valCode<>0 THEN 
  366.     BEGIN
  367.       Fehler(E_FREQVAL,'','');
  368.       goto 1;
  369.     END;
  370.     value := value * 1000;
  371.     rec^.freq:=long_trunc(value)
  372.   END;
  373.   p:=Pos(',',Line);                                  { Hmm?! }
  374.   IF p>3THEN 
  375.   BEGIN
  376.     Fehler(E_NOCOMMA,'','');
  377.     goto 1;
  378.   END;
  379.   MoveLine; 
  380.   IF Line1='' THEN 
  381.   rec^.rad:=0
  382.   ELSE 
  383.   BEGIN
  384.     Val(Line1,value,valCode);
  385.     IF valCode<>0 THEN 
  386.     BEGIN
  387.       Fehler(E_RADVAL,'','');
  388.       goto 1;
  389.     END;
  390.     rec^.rad:=Trunc(value)
  391.   END;
  392.   trim(Line);                                { Linkliste aufbauen }
  393.   IF Line[1]<>'(' THEN 
  394.   BEGIN
  395.     Fehler(E_NOLBRA,'','');
  396.     goto 1
  397.   END;
  398.   Delete(Line,1,1);
  399.   p:=Pos(')',Line);
  400.   IF p=0 THEN 
  401.   BEGIN
  402.     Fehler(E_NORBRA,'','');
  403.     goto 1
  404.   END;
  405.   MoveLine;
  406.   Line1:=concat(Line1,',');
  407.   p:=Pos(',',Line1);
  408.   WHILE p>1 DO 
  409.   BEGIN
  410.     New(link);
  411.     link^:=nullink;
  412.     IF rec^.links=NIL
  413.       THEN rec^.links:=link
  414.       ELSE link1^.next:=link;
  415.     link1:=link;
  416.     Line2:=Copy(Line1,1,Pred(p));
  417.     trim(Line2);
  418.     toUpper(Line2);
  419.     Delete(Line1,1,p);
  420.     p:=Length(Line2);
  421.     link^.lTyp:=Line2[p];
  422.     IF link^.lTyp IN SpecialLinks THEN Delete(Line2,p,1)
  423.                                   ELSE link^.lTyp:=' ';
  424.     IF invalidCall(Line2) = TRUE THEN 
  425.     BEGIN
  426.       Fehler(E_NOLCALL,Line2,'');
  427.       goto 1;
  428.     END;
  429.     link^.recP:=findCall(Line2);
  430.     p:=Pos(',',Line1);
  431.   END;
  432.   p:=Pos(',',Line);                                { Kommentar vorhanden ?}
  433.   IF p=0 THEN 
  434.   BEGIN
  435.     Fehler(E_NOCOMMA,'','');
  436.     goto 1;
  437.   END;
  438.   Delete(Line,1,p);
  439.   trim(Line);
  440.   IF Length(Line)>70 THEN 
  441.   BEGIN
  442.     Fehler(E_COMLEN,'','');
  443.     goto 1;
  444.   END;
  445.   rec^.comment:=Line;
  446. 1:
  447.  END;
  448.  
  449. BEGIN
  450.   writeln(chr(27),'f',chr(27),'EChkMap V1.0c ST');
  451.   ParamCount := cmd_args;                                    { Init }
  452.   if ParamCount >= 1 then cmd_getarg(ParamCount,ParamStr);
  453.   nulrec.lNum   := 0;
  454.   nulrec.call   := '';
  455.   nulrec.loc    := '';
  456.   nulrec.freq   := 0;
  457.   nulrec.typ    := 0;
  458.   nulrec.rad    := 0;
  459.   nulrec.links  := NIL;
  460.   nulrec.comment:= '';
  461.   nulrec.next   := NIL;
  462.   nullink.recP  := NIL;
  463.   nullink.lTyp  := ' ';
  464.   nullink.next  := NIL;
  465.  
  466.  
  467.   datOpen:=False;
  468.   hierHeap:=NIL;
  469.  
  470.   getFileName;
  471.  
  472.   io_check(false);
  473.   Reset(dat,DatFileName);
  474.   IF io_result <> 0 THEN 
  475.   BEGIN
  476.       io_check(true);
  477.     WriteLn('File ',DatFileName,' not found');
  478.     StopIt;
  479.   END
  480.   else io_check(true);
  481.   datOpen:=True;
  482.  
  483.   errcnt:=0;                                   { Nun geht's los! }
  484.   Rewrite(err,ErrFileName);
  485.   WriteLn(err,'General errors');
  486.   WriteLn(err);
  487.  
  488.   Mark(hierHeap);
  489.   New(recRoot);
  490.   recRoot^:=nulrec;
  491.   recRoot^.call:='      ';
  492.  
  493.   LineNum:=0;
  494.   recNum:=0;
  495.   WriteLn('Processing ',DatFileName);
  496.   WHILE NOT Eof(dat) DO 
  497.   BEGIN
  498.     rem:=False;
  499.     Inc(LineNum);
  500.     ReadLn(dat,Line);                    { Daten zeilenweise einlesen }
  501.     gotoxy(1,4);write(LineNum);
  502.     trim(Line);
  503.     IF Line[1]='#' THEN                  { Kommentare interessieren nicht }
  504.       rem:=True
  505.     else
  506.     begin                                { ansonsten: bearbeiten }
  507.       Inc(recNum);
  508.       Decode(Line);
  509.     end;
  510.   END;
  511.   Close(dat);
  512.   gotoxy(1,4);                           { kleine Statistik ausgeben }
  513.   Write(recNum,' records in ',LineNum,' lines   => ');
  514.   writeln(round((recNum/LineNum)*100),'%');
  515.   IF errcnt>0
  516.     THEN WriteLn(errcnt,' errors found   ',round((errcnt/recNum)*100),'%')
  517.     ELSE 
  518.     BEGIN                                { falls keine Fehler, }
  519.       gotoxy(0,8); write('Check Link list'); { Links Checken   }
  520.       WriteLn(err,'Linklist errors');
  521.       WriteLn(err);
  522.       CheckLinks;
  523.       IF errcnt>0 THEN                   { Fehler gefunden ?   } 
  524.       begin
  525.         gotoxy(0,9);
  526.         clreol;
  527.         gotoxy(1,9);
  528.         WriteLn(errcnt,' linklist errors found')
  529.       end;
  530.     END;
  531.  
  532.   Close(err);
  533.   write(chr(27),'e');
  534.   IF errcnt>0                            { Hinweis auf Fehler  }
  535.     THEN WriteLn(#10,'(See ',ErrFileName,' for Details)')
  536.     ELSE 
  537.     begin
  538.       WriteLn(#10,'No errors found');
  539.       erase(err);
  540.     end;
  541.   Release(hierHeap);
  542.   write(#10,#10,'Press >RETURN< to continue '); readln;
  543. END.
  544.  
  545.